COMMENT ⊗   VALID 00023 PAGES VERSION 16-2(43)
RECORD PAGE   DESCRIPTION
 00001 00001
 00003 00002	HISTORY
 00006 00003	Binary Operators
 00009 00004	
 00017 00005	Constant Binary Operators ----- Gtarts
 00019 00006	Unary Operators
 00022 00007	Exponentiation Code!
 00027 00008	Strings -- Concatenation
 00032 00009	           Substring, Length, Lop
 00037 00010	Point, Ldb, Ildb, Dpb, etc.
 00044 00011	Swap Operator.
 00049 00012	Store Operator
 00055 00013	Booleans -- Description
 00059 00014	            Variables
 00061 00015	            Arith→Relop
 00064 00016	            Relational Operators
 00072 00017	            Connectives, Negation
 00076 00018		    Constant Connectives
 00079 00019	    Gbol -- Discussion
 00083 00020	    Gbol
 00091 00021	If-Generators
 00097 00022	
 00099 00023		    BE→P Coercion
 00102 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  202000000053  ⊗;


COMMENT ⊗
VERSION 16-2(43) 10-23-72 BY JRL COMPILE ITEM COMPARISONS INLINE
VERSION 16-2(42) 9-27-72 BY RHT BUG #JG# REG B CLOBBERMENT CAUSED IDPB TO BECOME IBP IN BYPS
VERSION 16-2(41) 9-26-72 BY JRL BUG #JE# SAVE UNARY OP DISPATCH NUMBER AROUND CALL TO CONV
VERSION 16-2(40) 7-22-72 BY DCS BUG #IR# ILDB(A[I]) FIXED
VERSION 16-2(39) 7-9-72 BY RHT BUG #IM# FIX TRUE OR I BUG
VERSION 16-2(38) 7-5-72 BY JRL BUG #IJ# STRING ITEM NOT STRING IN STORE
VERSION 16-2(37) 6-30-72 BY DCS BUG #IA# BETTER AC PROTECTION IN STORE OPERATOR
VERSION 16-2(36) 5-22-72 BY JRL FIX BUG #HL# DESTRUCTION OF LEAP BITS WITHIN ITEM EXPRESSION STORES
VERSION 16-2(35) 5-17-72 BY DCS BUG #HK# FIX TEMP BUG IN SWPR (SWAP OPERATOR)
VERSION 16-2(34) 5-14-72 BY DCS BUG #HG# CONSTANT BOOLEAN FIX TO MAKE /H WORK
VERSION 15-2(14-33) 4-9-72 ALL SORTS OF THINGS
VERSION 15-2(10) 2-25-72 BY JRL FIX SVSTR
VERSION 15-2(9) 2-6-72 BY DCS BUG #GO# IN BINARY ARITH OR BOOL OPS, EXCH IF BOTH STTEMP
VERSION 15-2(8) 2-6-72 BY DCS BUG #FW# MAKE LOP(I) WORK RIGHT
VERSION 15-2(7) 2-5-72 BY DCS BUG #GJ# ADD LISTING CONTROL STUFF
VERSION 15-2(6) 2-5-72 BY DCS BUG #GI# CONCATENATION OF NUMBERS DONE BETTER
VERSION 15-2(5) 1-10-72 BY DCS BUG #FZ# MAKE ¬¬X WORK
VERSION 15-2(4) 1-3-72 BY DCS ADD EXPOP1, TWID21 EXECS FOR BE'S AS PRIMARIES
VERSION 15-2(3) 1-2-72 BY DCS ADD CHKCON ROUTINE TO ASSURE CONSTANT EXPR
VERSION 15-2(2) 1-2-72 BY DCS ADD EXPOP FOR NEW EX-BEX CLEANLINESS
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER

⊗;
SUBTTL	Binary Operators

BEGIN	ARITH
	LSTON	(EXPRS)
DSCR TIMDIV, PLUSM, MAXMIN
PRO TIMDIV, PLUSM, MAXMIN
DES Binary operator generators.
 The generators for + - XOR EQV & * / DIV MOD MAX MIN are all
  located in the environs.  This is perhaps the easiest piece
  of code to understand at the outset.  Everything is well
  behaved.  Syntactic contexts are:

 T @TD P SG → T SG		@TD TIMDIV
 E @PM T SG → E SG		@PM PLUSM
⊗


TABCONDATA (BINARY OPERATOR OPCODE TABLES)

PMTAB:	ADD (<FADR>)	;TABLE OF OPCODES FOR +,-,XOR,EQV
	SUB (<FSBR(1)>)(1)
	EQV 2,
	AND 2,
	IOR 2,
	XOR 2,


TDTAB:	IMUL (<FMPR>)			;  *
	IDIV (<FDVR (1)>) (1)		;  %
	FDVR 4,(1)			;  /
	LSH 3,(1)			; LSH
	ROT 3,(1)			; ROT
	IDIV (3)			; DIV
	IDIV (7)			; MOD

MXMNTB: CAMGE (<CAMGE>)			; MAX (COMMUTATIVE,
	CAMLE  (<CAMLE>)		; MIN   TYPELESS)

COMMENT ⊗
The table contains entries for the fixed point and floating
point operations.  The index field is used to indicate:
	Bit 1 -- order important
	Bit 2 -- must be fixed point operation.
	Bit 4 -- for MOD only -- means mark the second AC with the results.
	Bit 1 -- of ACcumulator field indicates needs immediate operand.
	Bit 2 -- NO type conversions necessary **** ???
	Bit 4 -- INSIST on REAL arguments.
⊗
ENDDATA

;THESE GENERATORS ARE ENTERED FROM THE PARSER.
;REGISTER "B" HAS AN INDEX IN IT -- THIS IS THE INDEX OF THE
;CLASS MEMBER (OPERATOR) WHICH IS INVOLVED IN THE CALL.

↑MAXMIN: MOVE	C,MXMNTB(B)		;MAX OR MIN
	JRST	PLSMDO			;USE COMMON BINARY OP CODE



↑TIMDIV: CAIL	B,7		;IS THIS THE STRING OPERATOR & ?
	JRST	CONCAT		;YES
	SKIPA	C,TDTAB(B)	;PICK UP OPERATOR
↑PLUSM:	MOVE	C,PMTAB(B)	;FOR PLUS OR MINUS , ETC.
PLSMDO:	MOVEM	C,OPCODE	;SAVE THE OPCODE
;;#GO# DCS (1-4) IF BOTH ARGS ARE STRING TEMPS, FETCHING THE
;; #GO#          SECOND OPERAND WILL WORK WONDERS
	PUSHJ	P,GTARGS	;ARG1'S SEM TO PNT, ETC., ARG2'S TO PNT2, ETC.
;;#GO# (1) FETCHED ARG2 TO AC IF BOTH STRING TEMPS, TO GET ORDER RIGHT
	HRRI	FF,ARITH!POSIT!BITS2	;JUST INSIST ON ARITH ARG IF
	TLNE	C,100		;NO CONVERSIONS TO DO?
	JRST	TPGO
	MOVEI	B,INTEGR
	TLNE	C,200		;DO WE REQUIRE REAL ARGS.?
	MOVEI	B,FLOTNG	;YES
	HRRI	FF,INSIST!POSIT!BITS2	;GOING TO INSIST FROM NOW ON.
	TLNE	C,202		;DO WE REQUIRE BOTH ARG'S FIXED?
	JRST	TPGO		;YES.

TPCHK:	TRNN	TBITS,FLOTNG
	TRNE	TBITS2,FLOTNG		;IF EITHER ARE FLOTING, DO
	JRST	[MOVSS OPCODE		;SOME IMPORTANT THINGS.
		 MOVEI B,FLOTNG		;PREPARE FOR GENMOV.
		 JRST	.+1]
TPGO:	
	GENMOV	(CONV)			;TYPE IS ALREADY IN B.
	TRO	FF,EXCHIN!EXCHOUT
	GENMOV	(CONV)			;NOW REPEAT FOR THIS ONE.


;NOW SEE WHICH ARGUMENTS ARE WHERE (IN ACCUMULATORS,
;OR WHATEVER.  TRY TO DO THINGS IN THE BEST ORDER.

	TLZ	FF,FFTEMP	;A RANDOM FLAG
	HLLZ	A,OPCODE	;GET THE OPCODE BITS.
	TLNE	SBITS,INAC	;IS FIRST ARG IN AC?
	JRST	OKORD		;YES -- WE ARE IN LUCK.
	TLNE	SBITS2,INAC	;IS SECOND ARG IN AC?
	JRST	BADORD		;YES -- THIS ORDER IS BAD
	TLNE	TBITS2,CNST	;A CONSTANT ?
	TLNN	TBITS,CNST	;FIRST ARG ALSO A CONSTANT?
	JRST	OKORD
	JRST	ALLCON		;YES -- COMPUTE IT NOW

BADORD:	TLNE	A,1		;IS ORDER IMPORTANT?
	JRST	F4WIN		;YESS -- TOUGH LUCK.
REVORD:	EXCHOP			;INTERCHANGE ARGUMENTS FINALLY

OKORD:	TLZ	A,777		;MASK OFF HORSESHIT BITS.
	HRRI	FF,POSIT!BITS2	;WE NEED TO GET THE FIRST ARG IN AC.
	CAMN	A,[IDIV ]	;IS THIS THE SPECIAL OPCODE?
	TRO	FF,DBL		;WE NEED A DOUBLE AC.
	GENMOV	(GET)		;CALL THE WIZARD.
				;AC NUMBER IS RETURNED IN D.
	TRNN	TBITS2,FLOTNG	;IF ARG IS FLOATING OR
	TLNN	TBITS2,CNST	;NOT CONSTANT, THEN NO HOPE OF OPTIMIZING
	 JRST	 NOOOP		;JUST EMIT THE INST.
	HLRZ	A,OPCODE	;GET OPCODE
	CAIL	A,220000	;IMUL
	CAILE	A,230001	;IDIV.-- THIS EXCLUDES MOD AND DIV
				;THE REASON IS THAT -1 MOD 2 SHOULD BE 0.
				;BUT THE ASH WOULD MAKE -1 MOD 2 BE -1
	 JRST	 NOOOP		;NO OPTIMIZATION.
	MOVE	B,$VAL(PNT2)	;PICK UP VALUE
	PUSHJ	P,PWR2		;IS IT A POWER OF TWO?
	 JRST	 NOOOP		;NO OPTIMIZATION.
	CAIE	A,(<IMUL>)	;A DIVIDE?
	MOVNS	C		;YES .......
ASHGO:	MOVE	A,[ASH USADDR+NORLC]
	JRST	EMGOX		;EMIT OPTIMAL INSTRUCTION.
NOOOP:
EMCN:	EXCHOP
	GENMOV	(ACCESS,PROTECT!UNPROTECT) ;GET ACCESS TO SECOND OPERAND.
	HLLZ	A,OPCODE	;ALL READY TO GO TO EMITER.
	TLZ	A,737		;TURN OFF CONTROVERSIAL BITS.
	TLZE	A,40
	JRST	[TRO A,USADDR!NORLC	;PREPARE FOR CONSTANT OPERAND.
		 HRL C,$VAL(PNT)	;VALUE
		 TLNE TBITS,CNST	;WERE WE JUSTIFIED?
		 JRST .+1		;YES
		 PUSH P,A		;THIS IS FOR ROT AND LSH, ETC.
		 HRLS  D		;WE WANT A NEW ACCUMULATOR.
		 GENMOV (GET,INDX!POSIT!PROTECT);WHILE WE PROTECT THIS ONE
		 MOVSS D		;SWAP BACK FOR THE OPERATION.
		 HRRZS	ACKTAB	(D)	;UNPROTECT ARG1'S
		 POP P,A		;FOR THE OP CODE.
		 HRRI A,USX!NOADDR
	 	 JRST .+1]
EMGOX:	PUSHJ	P,EMITER	;DO THE EMIT. !! AN ARITHMETIC INSTRUCTION !!

EXIT:	MOVE	A,OPCODE
	TLNE	A,4		;IS IT "MOD"
	JRST	[PUSHJ	P,CLEARA	;YES -- THIS AC HAS BEEN CHANGED.
		 ADDI	D,1		;YES--MARK THE SECOND ACCUMULATOR
		 JRST .+1]
	MOVS	TEMP,A		;IF MAX OR MIN, BOTH HALVES ARE
	CAMN	TEMP,A		;EQUAL, THIS DETECTS IT
	JRST	[PUSHJ P,CLEARA		;WE'RE GOING TO REPLACE IT
		 GENMOV (GET,SPAC) ;TEST FAILED, GET OTHER VAL
		JRST .+1]	;VERRRY SIMPLE

	TLZE	FF,FFTEMP	;SHOULD WE MARK NEGATIVE?
	TLC	SBITS,NEGAT	;JUST FLIP THIS BIT!
	PUSHJ	P,REMOP		;REMOP THE FIRST ARGUMENT,
	PUSHJ	P,REMOP2	;AND THE SECOND.
	TLNN	A,100		;DID WE SAY "NO CONVERSIONS."?
	JRST	MARK1		;NO -- GENMOV(MARK)!↔ MOVEM PNT,GENRIG+1
	GETSEM	(3)		;YES -- GET THIS FOR MARKING.
	TRNE	TBITS,STRING	;IN CASE SOME FUCKER LSHED A STRING
	MOVEI	TBITS,INTEGR
	JRST	MARK1		;GENMOV(MARK) ↔ MOVEM PNT,GENRIG+1

F4WIN:	
	CAME	A,[SUB (1)]	;IS IT THE SUBTRACT GIVING US TROUBLE?
	JRST	OKORD		;NO -- LIVE WITH THE ORDER.
	TLO	FF,FFTEMP	;YES -- INDICATE SIGN SHOULD BE FLIPPED.
	JRST	REVORD		;GO REVERSE THE OPERANDS.

SUBTTL	Constant Binary Operators ----- Gtarts

ALLCON:	HLLZ	A,OPCODE
	HRRI	A,$VAL(PNT2)	;ADDRESS OF ARGUMENT.
	TLNE	A,40		; NEED IMMEDIATE OPERAND?
	HRR	A,$VAL(PNT2)	; YES.
	TLZA	A,777
GETC:	HLR	A,C		;GET THE IMMEDIATE RESULT FROM OPCHK.
	SKIPA	B,$VAL(PNT)	;THE FIRST ARGUMENT.
ALCON1:	HRRI	A,$VAL(PNT)	;THE UNARY ARGUMENT.
	TLO	A,B*40
	MOVEI	TEMP,1		;DETECT SKIPS, FOR THOSE WHO CARE
	XCT	A		;DO THE OPERATIONS.
	MOVEI	TEMP,0		;DIDN'T SKIP 
CONRET:	MOVEM	TBITS,BITS
	MOVS	A,OPCODE
	CAMN	A,OPCODE	;MAX OR MIN?
	 JRST	 [JUMPN TEMP,.+1   ;SKIPPED, VALUE OK
		 MOVE B,$VAL(PNT2)  ;NO SKIP, ANS IS THIS ONE
	  JRST .+1]
	MOVEM	B,SCNVAL	;RESULT
	TRNE	A,4		;A "MOD"
	MOVEM	C,SCNVAL
	PUSHJ	P,CONINS	;MAKE A CONSTANT
	JRST	PUT1		;MOVEM PNT,GENRIG+1 ↔ POPJ P,

;;#GO# DCS 2-6-72 (2-4)
↑GTARGS:GETSM2	(1)		;ARG2'S SEMANTICS TO PNT2, TBITS2, SBITS2
	GETSEM	(3)		;ARG1'S SEMANTICS TO PNT,  TBITS,  SBITS
	TLNE	SBITS,STTEMP	;IS FIRST A STRING TEMP?
	TLNN	SBITS2,STTEMP	;YES, IS SECOND?
	 POPJ 	 P,		; AT LEAST ONE ISN'T
	GENMOV	(GET,ARITH!EXCHIN!REM);FETCH 2D SO ORDER WILL BE RIGHT
	MOVEI	TBITS,INTEGR	;MARK AS AN INTEGR
	GENMOV	(MARK,EXCHOUT)
	POPJ	P,
;;#GO# (2)
SUBTTL	Unary Operators

DSCR UNARY
PRO UNARY
DES Unary Operators.
 This generator is called from the parser with an index
  in B which corresponds to the operator seen.
 The syntactic contexts are:

 @UNOPE P SG → P SG	@UNOPE UNARY
⊗

↑UNARY:	MOVE	PNT,GENLEF+1	;GET SEMANTICS OF ARGUMENT.
;; #JE# BY JRL 9-26-72 SAVE DISPATCH INDEX AROUND CALL TO CONV
	PUSH	P,B
	GENMOV	(CONV,ARITH!GETD) ;INSIST ON ARITHMETIC TYPE.
	POP	P,B
;; #JE#
	XCT	UNTAB(B)	;DISPATCH
UNTAB:	JRST	UNOT		;UNARY NOT.
	JRST	UNABS		;ABSOLUTE VALUE
	JRST	PUT1		;UNARY PLUS IS ALMOST A NO-OP
	JRST	UMIN		;UNARY MINUS



UNOT:	SKIPA	A,[SETCM POSIT]
UNABS:	MOVSI	A,(<MOVM>)
UGOO:	MOVEM	A,OPCODE
	TLNE	TBITS,CNST	;A CONSTANT?
	JRST	ALCON1		;USE ARITHMETIC CONSTANT FOR EXIT.


GETAB:	HRRZ	D,$ACNO(PNT)	;GET AC NUMBER
	GENMOV	(ACCESS)	;DO ALL GOOD THINGS.
	TLNN	SBITS,INAC
	PUSHJ	P,GETAC		;GET A NEW AC IF WE DON'T HAVE ONE.
	HLLZ	A,OPCODE	;PICK UP OPCODE
	PUSHJ	P,EMITER	;EMIT A MOVN OR MOVMS
	PUSHJ	P,REMOP		;REMOP THE OPERAND.
	TLZ	SBITS,NEGAT	;LEAVE THIS UNFORTUNATE BIT OFF.
	JRST	MARK1		;GENMOV (MARK) ↔ MOVEM PNT,GENRIG+1

UMIN:	
	TLNN	TBITS,CNST		;ONLY THESE DON'T QUALIFY.
	TLNN	SBITS,INAC		;CAN ONLY BE FOR REG. VARBS.
					;I.E. NOT INDEXED VARIABLES.
	JRST	[MOVSI	A,(<MOVN>)
		 JRST	UGOO]
	TLC	SBITS,NEGAT	;HO HO
	MOVE	D,$ACNO(PNT)		;AC IT'S IN
	GENMOV	(MARK,0)		;MAKE IT A TEMP!
	JRST	PUT1			;GO AWAY, RECORDING

BEND	ARITH
SUBTTL	Exponentiation Code!

BEGIN	EXPON
EXTERNAL FLOGS,LOGS			;FIND A BETTER PLACE FOR EXTERNAL DECL

DSCR EXPON
PRO EXPON
DES Exponentiation routines.
	R. Smith
	
	ALGORITHM

	<exp1>↑<exp2> is evaluated at compile time if both
are constants.  If both are integers and <exp2> is geq 0, then
this evaluation produces an integer, otherwise a real.  Errors
are:  1)  0↑0 (default 1), and 2) arithmetic overflow (default
largest integer).  Otherwise the routines in GOGOL are called for
the compile-time evaluation.	
	If <exp2> is a positive integral constant, then a series
of imuls or fmps is compiled inline.  
	In other cases, the appropriate routine is called, as
below.  All routines return reals.

Argument	Exponent	Run-time routine
----------------------------------------------
INTEGR		INTEGR		POW
REAL		INTEGR		FPOW
INTEGR		REAL		LOGS
REAL		REAL		FLOGS
⊗


;;#GO# DCS 2-6-72 (3-4)
↑EXPON:PUSHJ	P,GTARGS	;SEM'S OF ARGS, 2D TO AC IF BOTH STTEMP
;;#GO# (3)
	TLNN	TBITS2,CNST	;IF EXPONENT IS CONSTANT
	  JRST	EXRTN1		;USE ROUTINES
	TLNE	TBITS,CNST	;AND BASE IS CONSTANT
	  JRST	ALLCN		;THEN EVALUATE NOW
	TRNN	TBITS2,INTEGR	;IF EXPONENT IS INTEGER, THEN COMPILE IN-LINE
	  JRST	EXRTN1		;NEED TO CALL RUNTIME ROUTINES.

	SKIPGE	B,$VAL(PNT2)	;EXPONENT (CONSTANT)
	 JRST	 EXRTN1		; NEGATIVE, CALL SUBROUTINE
	MOVE	SP,[IMUL USADDR!NORLC]
	MOVE	A,[MOVEI USADDR!NORLC]
	MOVSI	C,1
	TRNE	TBITS,INTEGR	;ARGUMENT INTEGER?
	JRST	FXDEX		;YES -- ALL SET.
	HRLI	SP,(<FMP>)
	HRLI	A,(<MOVSI>)
	HRLI	C,(1.0)
FXDEX:	

	PUSHJ	P,PWR2		;IS IT A POWER OF TWO?
	 JRST	 NOASH		;NO.
	HLRZ	SBITS2,C	;SAVE COUNT FROM PWR2
	GENMOV	(GET,POSIT)
	JUMPE	SBITS2,EXMRK	;IF IT WAS ARG ↑ 1 ;
ANOMUL:	HRL	C,D		;THE AC NUMBER.
	MOVE	A,SP		;THE INSTRUCTION.
	PUSHJ	P,EMITER
	SOJG	SBITS2,ANOMUL	;MORE TO GO ?
	JRST	EXMRK
NOASH:
	PUSHJ	P,GETAC
	PUSHJ	P,EMITER	;MOVEI AC1,1 
	SKIPN	B		;EXPONENT ZERO?
	JRST	EXMRK		;YES -- ALL DONE.
	PUSH	P,D
	SETOM	ACKTAB(D)
	GENMOV	(GET,POSIT)		;GET ARGUMENT.
	HRL	C,D
POWLUP:	MOVE	A,SP
	HRR	D,(P)
	TRNE	B,1		;OUTPUT THE IMUL ?
	PUSHJ	P,EMITER	;IMUL AC1,AC2
	HLR	D,C
	ASH	B,-1
	JUMPE	B,POWDUN
	MOVE	A,SP
	PUSHJ	P,EMITER	;IMUL AC2,AC2
	JRST	POWLUP
POWDUN:	POP	P,D
	SETZM	ACKTAB(D)
EXMRK:	PUSHJ	P,REMOP		;REMOP THE FIRST ARGUMENT,
	PUSHJ	P,CLEAR		;THE AC WITH ARG IN IT HAS CHANGED!
	PUSHJ	P,REMOP2	;AND THE SECOND.
	JRST	MARK1		;GENMOV(MARK) ↔ MOVEM PNT,GENRIG+1


;TO EVALUATE THESE WE WILL CALL THE RUNTIME ROUTINES.  ALL ERRORS
;(E.G.  0↑0) ARE HANDLED PLAUSIBLY IN THOSE  ROUTINES
;I↑J IS HANDLED HERE IF J>0, AND HAS TYPE INTEGR

ALLCN:	TRNE	TBITS2,INTEGR	;IF EXPONENT IS INTEGER
	TRNN	TBITS,INTEGR	;AND BASE AS WELL
	   JRST EXCC1		;NO, RETURN A REAL
	SKIPGE	B,$VAL(PNT2)	;AND EXPONENT IS POSITIVE	
	   JRST EXCC1
	MOVE	A,$VAL(PNT)	;BASE
	JUMPE	B,EXPZ		;IF EXPONENT IS ZERO
	MOVEI	C,1
	JRST	2,.+1		;CLEAR APR FLAGS

EXPLUP:
	TRNE	B,1	
	IMUL	C,A
	  JOV	POWOV		;OVERFLOW
	ASH	B,-1
	JUMPE	B,RETINT	;DONE
	IMUL	A,A
	  JOV	POWOV
	JRST	EXPLUP

POWOV:	ERR <ARITHMETIC OVERFLOW IN EVALUATING CONSTANT EXPONENTIATION
AS AN INTEGER, WILL TRY EVALUATION AS REAL.>,1
	JRST	EXCC1		;

EXPZ:	SKIPN	A		;0↑0?
	   ERR <0↑0 NOT DEFINED>,1
	MOVEI	C,1		;ASSUME HE WANTS 1.0
RETINT: MOVEI	TBITS,INTEGR	;ASSUME INTEGER
	MOVEM	TBITS,BITS	;MARK
	MOVEM	C,SCNVAL	;VALUE GENERATED
	PUSHJ	P,CONINS	
	JRST	PUT1		;MOVEM PNT,GENRIG+1    POPJ P,


EXCC1:	PUSH	P,$VAL(PNT2)	;EXPONENT
	PUSH	P,$VAL(PNT)	;BASE
;FIRST, TEST BASE
	TRNN	TBITS,INTEGR	;IS IT AN INTEGER?
	   JRST RELBAS		;BASE IS REAL
;BASE IS INTEGER, LOOK AT EXPONENT
	TRNE	TBITS2,INTEGR	
	PUSHJ	P,POW		
	TRNE	TBITS2,FLOTNG
	PUSHJ	P,LOGS
	JRST	RETREL		;RETURN A REAL
;BASE IS REAL, LOOK AT EXPONENT
RELBAS:
	TRNE	TBITS2,INTEGR
	PUSHJ	P,FPOW
	TRNE	TBITS2,FLOTNG
	PUSHJ	P,FLOGS
RETREL:
	MOVEI	TBITS,FLOTNG	;MARK AS FLOTNG
	MOVEM	TBITS,BITS	;FOR CONINS LATER.
	MOVEM	1,SCNVAL	;AND THE VALUE GENERATED.
	PUSHJ	P,CONINS	;WATCH THE MAGIC.
	JRST	PUT1		;MOVEM PNT,GENRIG+1 ↔ POPJ P,



EXRTN1:	EXCHOP
EXROUT:	GENMOV	(STACK,ARITH)	;STACK THE EXPONENT.
	GENMOV	(STACK,EXCHIN!ARITH)	;AND THE ARGUMENT.
	XPREP
	MOVNI	A,2
	ADDM	A,ADEPTH		;TO READJUST STACKS.
	TRNN	TBITS2,INTEGR	;ARGUMENT INTEGER?
	JRST	LOGSS		;NO

	TRNE	TBITS,INTEGR
	JRST	[XCALL	<POW>
		 JRST	EXMRK1]
	XCALL	<FPOW>
	JRST	EXMRK1

LOGSS:	TRNE	TBITS,INTEGR
	JRST	[XCALL	<LOGS>
		 JRST	EXMRK1]
	XCALL	<FLOGS>
EXMRK1: PUSHJ P,REMOP		;REMOP THE FIRST ARG
	PUSHJ P,CLEAR			; THE AC WITH ARG IN IT CHANGED
	PUSHJ P,REMOP2		;AND THE SECOND
	MOVEI TBITS,FLOTNG	;MARK RESULT AS FLOATING
	JRST MARK1		;GENMOV(MARK)

BEND	EXPON
SUBTTL	Strings -- Concatenation

BEGIN	STRING

DSCR CONCAT
PRO CONCAT
DES Concatenation operator handling.
 CONCAT is called from the TIMDIV binary expression generators. It
  must stack both arguments, and decide which runtime routine to call
  based on the types of the arguments.  A very special case is that of
  <constant or variable> & <expression>, wherein the 2d argument has
  already been stacked -- in this case CAT.RV is called, which assumes
  that the top stack element is arg1, the next element is arg2.

 The syntactic context:

T1:  T @TD P SG → T SG	@TD MULDIV →→→→ CONCAT
⊗

;;#  # 4-9-72 DCS TOTALLY REVISED TO IMPLEMENT CAT.RV -- SUPERSEDES #GI#
↑CONCAT: 
	MOVEI	C,0		;C indexes the routine name -- CAT to start.
	GETSEM	(3)		;If both arguments are constant, we'll
	GETSM2	(1)		; do the whole thing at compile time.
	TLNE	TBITS,CNST
	TLNN	TBITS2,CNST
	 JRST	 UNCON

CATBOT:	GENMOV	(CONV,INSIST!EXCHOUT,STRING)
	GENMOV	(CONV,INSIST,STRING)
	MOVE	SP,STPSAV	;We'll just use the CAT routine for
	MOVSS	POVTAB+6	; compile-time CAT, since results are
	PUSH	SP,$PNAME(PNT2) ; the same in any case, and we have no
	PUSH	SP,$PNAME+1(PNT2); good track record for compile-time
	PUSH	SP,$PNAME(PNT)	; efficiency anyway.
	PUSH	SP,$PNAME+1(PNT);Making sure we have an appropriate PDL
	PUSHJ	P,CAT		; for string operations, and the trap
	POP	SP,PNAME+1	; routines will identify it properly,
	POP	SP,PNAME	; we do the CAT, then insert the result
	MOVSS	POVTAB+6	; as a brand new string constant. Then
	PUSHJ	P,REMOP		; we just clean up and leave.
	PUSHJ	P,REMOP2
	PUSHJ	P,STRINS
	HRRM	PNT,GENRIG+1
	POPJ	P,

UNCON:	TRNN	TBITS,STRING	;Bit 1 means arg1 is ¬string (CHRCAT or
	 TRO	 C,1		; CHRCHR), Bit 2 means arg2 is ¬string
	TRNN	TBITS2,STRING	; (CATCHR or CHRCHR).  Both cases are
	 TRO	 C,2		; simple, because at most one string will be
	JUMPN	C,STACKM	; stacked on RSP, so order is not an issue.

	TLNN	SBITS,STTEMP	;When arg1 is not stacked yet, but arg2 was
	TLNN	SBITS2,STTEMP	; stacked during its evaluation, we must
	 JRST	 STACKM		; do some extra work

 ; Both strings, arg1 not stacked ∧ arg2 stacked

	MOVEI	C,4		;This code invokes CAT.RV (for ReVerse), which
	GENMOV	(STACK,0)	; will exchange its arguments or something
	PUSHJ	P,REMOP2	; before concatenating, to correct the above
	JRST	CALLM		; mis-stacking problem.

STACKM:	GENMOV	(STACK,EXCHOUT)	;One (or both) ¬string, or arg1 stacked, or
	GENMOV	(STACK,0)	; arg2 ¬stacked -- be sure both are stacked.

CALLM:	XCALL	<CAT(C)>	;CAT, CHRCAT, CATCHR, CHRCHR, or CAT.RV
	TRZ	C,4		;CAT and CAT.RV have similar DEPTH effects--
	MOVE	TEMP,[-2↔0↔0↔2](C); Adjust both stacks to account for the
	ADDM	TEMP,SDEPTH	;  difference between the number of words 
	MOVE	TEMP,[0↔-1↔-1↔-2](C); pushed, and the number remaining as
	ADDM	TEMP,ADEPTH	;     a result.
	MOVEI	TBITS,STRING	;Mark the result an STTEMP, and go away.
	PUSHJ	P,MARKME
	HRRM	PNT,GENRIG+1
	POPJ	P,
;;#  #
SUBTTL	           Substring, Length, Lop

DSCR SVSTR, SUBSTR
PRO SVSTR SUBSTR
DES EXECS for Substring operations
 SVSTR saves String Semantics on the LENSTR Qstack. This allows
  nested substrings and easy operation for ∞, without rummaging
  around the PP or GP stacks.
 SUBSTR issues substring code, given the two numeric arguments
  and the top of LENSTR; TO is differentiated from FOR via B
  (parse index)
⊗
↑SVSTR:	HRRZ	A,GENLEF+1	;LH ZERO INDICATES STRING (VERSUS LIST)
	QPUSH	(LENSTR)
	AOS	LENCNT
	POPJ	P,


↑SUBSTR:QPOP	(LENSTR)	;This was String Semblk, saved for ∞
	PUSH	P,GENLEF+1	;Use PCALL code in PROCED to call SUBSR (B=5),
	MOVEI	TEMP,.SUBSR	; or SUBST (4)-- B index from @NXT.
	CAIN	B,4		;.SUBST and .SUBSR are addrs of SUBST and SUBSR
	 MOVEI	 TEMP,.SUBST	; Semblks in RESTAB -- placed by RTRAN via FOO2
	MOVEM	TEMP,GENLEF+1	; request.  The GENLEF+... indices are:
	PUSHJ	P,RDYCAL		; +4 -- String Semblk
	MOVEW	(<GENLEF+2>,<GENRIG>)	; +3 -- Startchar expression
	MOVEW	(<GENLEF+1>,<GENLEF+4>) ; +1 -- Endchar or Charcount expression
	PUSHJ	P,CALARG	;The PROCED routines are used to prevent
	POP	P,GENLEF+1	; anomalous behavior, to guarantee correct
	PUSHJ	P,CALARG	; calling conversions in all cases, and to allow
	MOVEW	(<GENLEF+1>,<GENLEF+3>); substrings with constant arguments to
	PUSHJ	P,CALARG	; be done at compile time (FOO2 requests this
	JRST	ISUCAL		; feature for SUBSR and SUBST).

DSCR SLOP, LLEN
PRO SLOP LLEN LLEN1
DES EXECS to issue code to to LOP(STR) and LENGTH(STR) in line
⊗
↑SLOP:	PUSHJ	P,GETAN0
	MOVE	PNT,GENLEF+1
	GENMOV	(ACCESS,GETD!INSIST,STRING)
;;#FW# DCS 2-6-72 (1-1) LOP(I) DOESN'T WORK
	MOVEM	PNT,GENLEF+1	;STORE RESULT WHERE IT'LL BE LOOKED FOR
;;#FW# (1-1)
	MOVE	A,[HRRZ LNWORD] ;GET LENGTH FIRST
	PUSHJ	P,STROP		;LIKE THIS
	PUSH	P,PCNT		;SAVE THIS ADDRESS FOR FIXUP
	HRLI	C,0
	EMIT	(<JUMPE USADDR!NORLC>) ;RETURN 0 IF STRING EMPTY
	HRROI	C,<<ILDB> ⊗ -=27 >
	EMIT	(HRROI USADDR!NORLC) ;GET -1 IN AC.
	MOVE	TBITS2,[ADDM LNWORD!BPWORD!BPINC ]
	PUSHJ	P,STRGR		;AND FINISH OUT AND MARK IT.
	POP	P,B		;GET FIXUP ADDR
	HRL	B,PCNT		;FIXUP TO HERE
	PUSHJ	P,FBOSWP	;SWAP AND FBOUT
	MOVE	A,[REM!UNDO]	;NOW SUB IF NECESSARY AND REMOP
	GETSEM	(1)		;STRING SEMANTICS BACK AGAIN
	JRST	STROP


↑LLEN1:	SKIPA	TBITS2,[HRRZ LNWORD]	;SPECIAL -- FOR ∞ -- DO NOT DAMAGE STRING.
↑LLEN:  MOVE	TBITS2,[HRRZ LNWORD!UNDO] ;LENGTH OF STRING.
	PUSHJ	P,GETAN0		;IN CASE REFERENCE ARG, NEED INDEXABLE.
STRGR:	MOVE	PNT,GENLEF+1		;ARGUMENT.
	GENMOV	(ACCESS,GETD!INSIST,STRING)
	TLNE	TBITS,CNST		;IF A STRING CONSTANT NOW, JUST ANSWER
	 JRST	 CONLEN
	MOVE	A,TBITS2		;ARGUMENT TO STROP.
STRDO:	PUSHJ	P,STROP			;DO IT ON THE STRING.
	TRNE	FF,UNDO			;NOT IF SPECIAL (STROP LEFT IT THERE)
↑REMG0:	PUSHJ	P,REMOP
	PUSHJ	P,MARKINT		;MARK AN INTEGER.
G00:	MOVEM	PNT,GENRIG
	POPJ	P,

CONLEN:	HRRZ	A,$PNAME(PNT)		;THE ANSWER
	PUSHJ	P,CREINT		;A NUMERICAL CONSTANT
	JRST	G00			;TRIVIALITY

BEND	STRING
SUBTTL	Point, Ldb, Ildb, Dpb, etc.

BEGIN BYTE

DSCR BYPS, BYPQ, BYPE
PRO BYPS BYPQ BYPE
DES EXECS for LDB, ILDB, IBP, DPB, etc.
 They use the BYTAB, BYSAB tables in obvious ways to issue
  the obvious code
⊗

TABCONDATA (BYTE POINTER EXEC VARIABLES)
COMMENT ⊗
BYTAB, BYSAB -- used by byte pointer EXECS to create the appropriate
    byte pointer instructions.
⊗
BYTAB:	ILDB	4
	LDB
BYSAB:	IDPB	4
	DPB
IBPSAB:	IBP	NOUSAC!4
ENDDATA


↑BYPQ:	MOVEI	B,IBPSAB-BYSAB		;IMPLEMENT 1-ARGUMENT
;; #KI# BY JRL (11-21-72) DO THE DUMMY GETAC FOR IBP
	PUSHJ	P,GETAC
	JRST	BYPQ1			; VERSION OF IBP

↑BYPS:	MOVE	PNT,GENLEF+3		;THING TO BE DEPOSITED.
;;#JG# RHT 9-27-72 REGISTER B CLOBBERMENT
	PUSH	P,B
	GENMOV	(GET,GETD!POSIT!REM!ARITH);GET IT AND THEN REMOP IT.
	POP	P,B
;;#JG#
BYPQ1:	TLO	FF,FFTEMP		;A THING AT STATEMENT LEV.
	MOVE	A,BYSAB(B)		;GET INSTRUCTION.
	JRST	BY11
↑BYPE:	TLZ	FF,FFTEMP
	MOVE	A,BYTAB-4(B)		;INSTRUCTION.
	PUSHJ	P,GETAC			;GET AN AC FOR RESULT.
BY11:	PUSH	P,A			;SAVE
	MOVE	PNT,GENLEF+1		;EXPRESSION.....
	GENMOV	(ACCESS,GETD!PROTECT!UNPROTECT)		;ARG.
	POP	P,A			;RESTORE
;;#IR# 7-22-72 DCS ILDB/IDPB(..., ARRAY[EXPR]) DIDN'T WORK, CLEAN OTHERS UP
	TRNE	A,4			;For ILDB and IDPB operations,
;; #KE# BY JRL ALSO FIXARR OK
	TLNE	SBITS,INDXED!FIXARR	; temp (not counting INDXED) BPs
	 JRST	 BYOK			; make limited sense, so a message
	TLNE	SBITS,ARTEMP!STTEMP	; is issued.  In the same instances,
	 ERR	 <BYTE POINTER MODIFICATION USELESS>,1
	TLNN	SBITS,ARTEMP!STTEMP	; we must avoid using the INAC versions
	 PUSHJ	 P,INCOR		; of BP variables, so this is tested.
;;#IR#
BYOK:	PUSHJ	P,EMITER
	TLNN	FF,FFTEMP
	JRST	REMG0			;MARK AN INTEGER AND PUT IN GENRIG.
	JRST	REMOP			;GO AWAY.

Comment ⊗
 Because byte pointers are so often comprised of constant
size and position fields, and of simple variables as addresses
(??), it seems appropriate to create these byte pointers at
compile time.  Perhaps later a way can be determined to extend
this feature to more complicated things (at least FIXARR array calcs).

RTN:   BBPP @E ,			SCAN		↑EX1 ¬RTP
RTP:   BBPP @E , @E			SCAN		↑EX1 ¬RTP1
RTP1:  BBPP @E , @E , @E )		EXEC BPNT SCAN  ¬IE2

Only those cases for which the first two args are constants and the
last a simple real or integer variable will be considered.

⊗

↑↑BPNT:
	MOVEI	TBITS2,0
	GETSEM	(1)		;POSITION FIELD OF BYTE POINTER
	TLNN	TBITS,CNST	; MUST BE A CONSTANT
	 JRST	 CALLIT		;  OR WILL CALL AT RUNTIME
	GENMOV	(CONV,INSIST,INTEGR)	;INTEGER POSITION FIELD ONLY
	MOVEI	TEMP,=35	;CREATE REAL POSITION ENTRY
	SUB	TEMP,$VAL(PNT)
	DPB	TEMP,[POINT 6,TBITS2,5] ;AND MOVE TO APPROPRIATE LOC
	GETSEM	(5)		;SIZE FIELD
	TLNN	TBITS,CNST	; ALSO MUST BE CONSTANT
	 JRST	 CALLIT		;  OR CALL AT RUNTIME
	GENMOV	(CONV,INSIST,INTEGR)	;MUST BE INTEGRAL
	MOVE	TEMP,$VAL(PNT)	;SIZE VALUE
	DPB	TEMP,[POINT 6,TBITS2,11] ;TO SIZE AREA
	GETSEM	(3)		;ADDRESS FIELD OF BYTE POINTER
	TLNE	TBITS,CNST	;CONSTANT ADDRESS FIELD?
	 ERR	 <CONSTANT QUESTIONABLE AS BYTE POINTER ADDRESS>,1
	TDNN	TBITS,[XWD FORMAL!SBSCRP,STRING] ;REALLY RESTRICTED CLASS
	TLNE	SBITS,ARTEMP!STTEMP!FIXARR	; OF THINGS WILL BE PROCESSED
	 JRST	 CALLIT		;SORRY, CHARLIE!

	GENMOV	(INCOR)		;SAFETY FOR POOR LOSER SOMETIMES
	HLL	PNT,TBITS2	;BYTE POINTER STUFF FOR LH
	PUSHJ	P,ADRINS	;MAKE AN ADDRESS CONSTANT
	MOVEM	PNT,GENRIG	;THE RESULT!
	POPJ	P,

; SEE SLOP -- THIS IS THE MOST AMBITIOUS SIMULATION OF "PARSE" TO DATE

CALLIT:	PUSH	P,GENLEF+1	;SAVE ALL SORTS OF SEMANTICS FOR
	PUSH	P,GENLEF+3	; THE ARGUMENTS
	PUSH	P,GENLEF+5
	MOVEI	TEMP,.BBPP.	;WILL CALL THE POINT FUNCTION
	MOVEM	TEMP,GENLEF+1	;READY FOR RDYCAL
	PUSHJ	P,RDYCL1	;PREPARE TO CALL
	MOVEW	<GENLEF+2>,<GENRIG+1> ;SEMANTICS OF PROC BLOCK
REPEAT 3,<
	POP	P,GENLEF+1	;AN ARGUMENT
	PUSHJ	P,CALARG	; TO THE STACK
>
	JRST	ISUCAL		;FINISH UP


↑↑BPTWD:
	MOVE	TEMP,GENLEF+1
	MOVEM	TEMP,GENRIG+1
	POPJ	P,

BEND BYTE
SUBTTL	Swap Operator.

BEGIN	SWAP

DSCR SWPR
PRO SWPR
DES The swap operator to interchange two variables.

@ISTO ↔ @ISTO → S		exec swpr
⊗

↑SWPR:
	SOJL	B,SWPRK			;AN ARITHMETIC EXPR. OK.
;	JUMPE	B,ER51			;A BOOLEAN -- NO GOOD.
	JUMPE	B,ER41			;RLS REPLACEMENT
	PUSHJ	P,LEAVE			;IN LEAP...
SWPRK:	GETSM2	(3)
	GETSEM	(1)			;NOW HAVE SEMANTICS OF BOTH ARGS.
	TLNE	SBITS,ARTEMP!STTEMP	;IF A TEMP EXPRESSION, LOSE.
	TLNE	SBITS,INDXED!FIXARR	;EXCEPT ON SUBSCRIPTS.
	SKIPA
	ERR	<SWAP OPERATOR ON EXPRESSION>,1
	TRNN	TBITS,STRING
	TRNE	TBITS2,STRING		;DO STRING THINGS IF EITHER IS
	JRST	SWPSTR			;A STRING.
	PUSH	P,TBITS			;SAVE ORIGINAL TYPE
	MOVE	B,TBITS2
	GENMOV	(GET,INSIST!NONSTD!POSIT!EXCHOUT) 
					;GET FIRST ARG WITH TYPE OFSECOND.
					;BUT PRESERVE SEMANTICS OF INDXED TEMP.
	TLNN	SBITS,INDXED
	PUSHJ	P,INCOR			;MAKE SURE EXCH DEST. IS IN CORE
	GENMOV	(ACCESS,PROTECT!UNPROTECT);MAKE SURE CAN GET AT SECOND ARG.
	EMIT	(<EXCH>)		;DO THE EXCHANGE. NOW AC HAS TYPE
					;OF SECOND
	PUSHJ	P,REMOP			;DON'T NEED THIS ANY MORE
;;#HK#2↓ 5-17-72 DCS PREVENT TWO ARGS FIGHTING FOR SAME TEMP
	PUSH	P,ACKTAB(D)		;TEMPORARILY FORGET THAT THIS IS IN THIS
	SETZM	ACKTAB(D)		; AC, ALLOW A NEW TEMP TO BE BORN
	PUSHJ	P,MARKME		; (IN FACT, WE NEED A TEMP
; WAS MARK -- THAT WAS WRONG
					;  OF THIS TYPE IN THIS AC
;;#HK#↓
 	MOVE	B,-1(P)			;GET ORIG TYPE BACK (WAS POP P,B)
	GENMOV	(CONV,INSIST!POSIT!SPAC);CHANGE IT TO TYPE OF FIRST.
	PUSHJ	P,REMOP			;REMOVE THE TEMP
;;#HK#2↓
	POP	P,ACKTAB(D)		;REMEMBER OLD RESIDENT
	SUB	P,X11			;REMOVE SAVED TYPES
	TLZ	SBITS2,INAC
	MOVEM	SBITS2,$SBITS(PNT2)	;SO THAT THE EMITER WILL SEE IT.
	GENMOV	(PUT,EXCHIN)		;STORE BACK INTO FIRST
	JRST	REMOP			;FERTIG.

Comment ⊗
The string problem is a little messy.  If both are
strings, we just go ahead blithly.  First we load
up accumulators with the addresses of the two
strings.  Then we stack both strings.  Then we put together
instructions popping them off the SP stack, using the
addresses saved in the accumulators just gotten.
⊗


SWPSTR:	TRNE	TBITS,STRING	;HERE IF EITHER IS A STRING.
	TRNN	TBITS2,STRING
	ERR	<TYPE CONVERSIONS TOO MESSY>,1,CPOPJ
	GENMOV	(GET,ADDR!INDX)	;GET THE ADDRESS OF THE FIRST.
	PUSH	P,D
	GENMOV	(GET,EXCHIN!ADDR!INDX)
	PUSH	P,D
	GENMOV	(STACK,0)	;STACK THE FIRST STRING.
	GENMOV	(STACK,EXCHIN!EXCHOUT)	;AND THE SECOND (SEE THE GENMV2).
	HRL	D,(P)		;FOR THE INDEX FIELD
	PUSHJ	P,DOIT
	EXCHOP
	HRL	D,-1(P)
	SUB	P,X22
DOIT:	SETZM	C		;EMIT TWO POPS TO STORE THE STRING.
	EMIT	(<POP RSP,NOUSAC!USX!NOADDR>)
	SETOM	C
	EMIT	(<POP RSP,NOUSAC!USX!USADDR!NORLC>)
	MOVSS	D
	PUSHJ	P,CLEARA	;CLEAR AC # USED FOR SWAP
SUBTR:	MOVNI	A,2
	ADDM	A,SDEPTH	;WE HAVE TO BOOKEEP THIS COUNT.
	POPJ	P,		;DONE


BEND

SUBTTL	Store Operator

BEGIN	STORE

DSCR STORE
PRO STOR1
DES EXECS for the assigment operator.
 The store operators are handled mostly in the lower level
  generator code.  The only distinction made here is whether
  to do the remop.  STOR1 is called at expression level, 
  and therefore does no remop; STORE does the remop.

 The syntactic context is:
    LHS E SG → xxx		STORx

 The problems with STORE result from the expr store configuration:
     vbl ← (array descriptor) ← vbl;

 or worse:
     String vbl ← string array descriptor ← String vbl

 In this last case, we are careful to push the string on the
   SP stack, so that an add to the SP will deliver the String.
⊗


↑STOR1:	TLOA	FF,FFTEMP	;INDICATE NO REMOP
↑STORE:	TLZ	FF,FFTEMP	;INDICATE A REMOP
	SOJL	B,.+3		;REGULAR EXPRESSION
	JUMPN	B,LPSTOR	;..LEAP..
	PUSHJ	P,LEVBOL	;BOOLEAN.
;;#IA# 6-29-72 (1-6) DCS BETTER AC PROTECTION
↑STORG:	HRRZS	PNT,GENLEF+2	;Protect the AC if the destination is
	PUSHJ	P,GETAD		; a PTRAC temp (subscripted variable,
	TLNN	SBITS,PTRAC	; subscrp calc. in AC. -- This will prevent
	 JRST	 NOPTR		; the GET operation from storing the
	HRRZ	D,$ACNO(PNT)	; pointer, only to have to pick it up
	HRROS	ACKTAB(D)	; again to do the STORE.
	HRROS	GENLEF+2	;Indicate that this was done
;;#IA#(1-6)
NOPTR:	HRRZ	B,TBITS		;DESTINATION TYPE.
	MOVE	PNT,GENLEF+1	;SOURCE
	MOVEI	D,RSP		;USE THIS STACK.IN CASE STRINGS.
	HRRI	FF,INSIST!EXCHOUT!GETD;WE WANT TO "GET" THE SOURCE.	
;;#IJ# JRL 7-5-72 A STRING ITEMVAR IS NOT A STRING
	TRNE	B,ITEM!ITMVAR
	JRST	NOPTR1
;;#IJ#
	TLNE	FF,FFTEMP	;IF STANDARD STORE
	TRNN	B,STRING	;OR DESTINATION NOT A STRING
	JRST	[NOPTR1:GENMOV (GET)
		 CAIE D,RSP
		 JRST GENGO
		 JRST GENG1]
	GENMOV	(STACK)
GENG1:	TRZA	FF,-1
GENGO:	HRRI	FF,PROTECT!UNPROTECT
	MOVE	PNT,GENLEF+2	;AND GET DESTINATION SEMANTICS.
	TRO	FF,GETD		;ADD TO (PERHAPS) PROTECTION
	PUSHJ	P,ACCESS	;ASSURE ACCESS TO IT (PERHAPS PROTECT AC)
;;#IA# 6-30-72 DCS (2-6) UNPROTECT DEST IF NECESSARY
	JUMPGE	PNT,NOUNP	;IF WAS PROTECTED, UNDO
	HRRZ	TEMP,$ACNO(PNT)
	HRRZS	ACKTAB(TEMP)
;;#IA# (2-6)
NOUNP:	TLNE	SBITS2,NEGAT	;COPY THIS BIT INTO THE THING TO MARK 
	TLO	SBITS,NEGAT	;FOR STORING.
	HRRI	FF,0
	TLNE	FF,FFTEMP	;IF AN EXPR. STORE, THEN
	TRO	FF,NONSTD	; BE SURE TO SAVE INDXED TEMPS.
	GENMOV	(PUT)		;MARK THE STORE.
	PUSHJ	P,REMOP2	;REMOP THE EXPRESSION PART OF THINGS.
	TLNN	FF,FFTEMP	;EXPRESSION STORE ?
	JRST	REMOP		;REMOVE THE DESTINATION IF TEMP.
				;PNT NOW HAS DESTINATION IN IT.
	TLNE	SBITS,STTEMP
	TRNN	TBITS,STRING	;IF WE ARE NOT TO MARK STRING, THEN
	JRST	[TRNE TBITS,ITMVAR!SET 
;#HL#. FOLLOWING WAS HRRZM WHICH WIPED OUT INFO IN LEFT HALF.
		 HRRM	PNT,@LEAPSK	;RESTORE THE TOP OF LEAP STACK.
		JRST	 PUT1]		;JUST RETURN SEMANTICS.
	MOVE	PNT2,PNT	;SAVE FOR LATER.
	MOVE A,X22		;FIRST ADD TO THE STACK.
	PUSHJ P,CREINT
	EMIT (<ADD RSP,NOUSAC>)
	MOVEI	A,2
	ADDM	A,SDEPTH	;AND FIXUP THIS WONDERFUL COUNT.
	MOVE	PNT,PNT2
	MOVE	TBITS,$TBITS(PNT);RESTORE BITS.
↑MARK1:	GENMOV	(MARK,0)	;YES -- GO MAKE A TEMP.
				;WE MUST DO THIS IN CASE OF INDEXED VBLS.
↑PUT1:	MOVEM	PNT,GENRIG+1	;SAVE AS SEMANTICS.
↑CPOPJ:	POPJ	P,		;STORE AS THE SORUCE FOR THE NEXT.


BEND	STORE
SUBTTL	Booleans -- Description

BEGIN	BOOLEAN
DSCR --Boolean Expression code
DES very hairy.
SEE incredibly complex RFS comments below this DSCR
⊗
COMMENT ⊗
This section contains the routines for generating the code
for boolean expressions.

It consists of 3 parts:
1.	A routine called to promote an arithmetic expression
	to a boolean primary, or to promote a simlpe boolean
	variable to a boolean primary.

2.	A routine to generate compare code for relational expressions.

3.	Routines called from the boolean expression productions, e.g.
	BOOR, BOAND, and BONOT.

The routines above all generate information in free storage blocks.
These are classed in two categories, terminal nodes (one to
represent each boolean primary) and non-terminal nodes (one for each
logical operation, such as NOT, OR, AND).  The recursive routine
GBOL wanders through this structure, outputting necessary code and
address fixups to the binary file.  It deletes all the storage
entries as it goes.  The format of each entry looks like:

1. TERMINALS.
	$DATA	xwd conbits,pointer to right brother.
	$ACNO	xwd pcnt of first instr of compare,type
		(type = 1 for a jumpxx, =2 for a camxx jrst)
	$ADR	xwd relocation bit for first word of code,bit for second
	$VAL	first word of code as emitted.
	$VAL2	second word of code as emitted.

   Conbits are declared in bit list below

2. NON-TERMINALS.
	$DATA	xwd gtype+400000,pointer to right brother
	$DATA2	pointer to left son.

   Gtype bits are declared below.
	
The syntactic contexts are:

NOT BP SG → BP SG		BONOT
BT AND BP SG → BT SG		BOAND
BE OR BT SG → BE SG		BOOR


⊗

BITDATA (BOOLEAN TREE ELEMENTS)

; Nonterminals
	GBAND	←←4		;TYPE BIT FOR "AND"
	GBOR	←←10		;FOR "OR"
	      GBPOS←←15		;   POSITION OF GBAND IN LH OF TYPE WD
	GBNOT	←←20		;AND "NOT"
	GINVRT	←←40		;INVERT SENSE BIT.
	MOSTTRUE←←100		;MOST SONS ARE TRUE.
	LASTTRUE←←200		;LAST SON IS TRUE.
	METRUE←←400		;I AM TRUE TO YOU, MY DEAR.
	FLSFIX←←1000		;SOMEONE STARTED A FALSE FIXUP.
	TRUFIX←←2000		;OR A TRUE FOR THAT MATTER.
; Terminals
	TRUCON←←2		;TRUE CONSTANT
	FLSCON←←1		;FALSE CONSTANT
	BOLCON←←TRUCON!FLSCON	;EITHER
ENDDATA
SUBTTL	            Variables

ZERODATA (BOOLEAN EXPRESSION VARIABLES)

;FAPDL -- special push-down list for storing addresses of code
;    which jump to false addresses -- used to get fixups right
BPDL←←10
↓FAPDL:	BLOCK	BPDL

;TRPDL -- corresponding stack for true addresses
↓TRPDL:	BLOCK	BPDL

↓LPSAV:	0		;PLACE TO PUT LPSA SOMETIMES

TABCONDATA (BOOLEAN EXPRESSION VARIABLES)

COMMENT ⊗
CONVS, CONVT -- conversion routines
  CONVS converts the bits of a compare or jump instruction
  to those needed to reverse the meaning of a compare (jump
  on False condition instead of True, for instance).  
  CONVT converts the bits to those needed to reverse the operands
  of a compare (2d operand already in AC, for instance).
⊗

CONVT:	0
	7 ↔ 2 ↔ 5 ↔ 4 ↔ 3 ↔ 6 ↔ 1 

CONVS:	4
	5 ↔ 6 ↔ 7 ↔ 0 ↔ 1 ↔ 2 ↔ 3

;RELTAB -- conditional bits (to go into instructions) corresponding
;   to the class index of the condition (=, <, >, etc.) from the source
;   file -- used to convert class index to instruction bits

↑RELTAB: 1	;<
	7	;>
	2	;=
	6	;≠
	3	;≤
	5	;≥
;	0	;TRUE
;	4	;FALSE

ENDDATA
SUBTTL	            Arith→Relop

DSCR BOOP, BOREL
PRO BOOP BOREL BOREL1
DES EXECS to generate compare/jump code for simple relations
  and implied relations ("IF A<B"  or "IF A")
SEE Above-mentioned comments for more help
⊗
;COME HERE TO CONVERT A BOOLEAN VARIABLE OR ARITHMETIC EXPRESSION
;INTO A BOOLEAN PRIMARY.  A "PRIMARY" BLOCK IS CREATED.

↑BOOP:	TLO	FF,FFTEMP	;WILL REMOP THE FIRST ARGUMENT
	GETBLK	<GENRIG+1>	;GET A FREE STORAGE BLOCK AND ATTACH TO 
	
	MOVE	PNT,GENLEF+1	;THIS IS THE ONE WE WANT TO PROTECT FROM
	GENMOV	(CONV,GETD!ARITH) ;IN CASE THE BASTARD INSISTS ON STRINGS.

;;#  # DCS 2-28 CONSTANT EXPRS
	TLNE	TBITS,CNST	;IF CONSTANT, DETERMINE TRUE/FALSE
	 JRST	 [MOVSI TEMP,TRUCON ;ASSUME TRUE
		  SKIPN $VAL(PNT)
	     FL:  MOVSI	TEMP,FLSCON ;ASSUMPTION INVALID
	     TR:  MOVE	LPSA,GENRIG+1;UPDATE RESULT
		  MOVEM TEMP,$DATA(LPSA)
		  JRST	REMOP]	;TOSS OUT NUMERIC (OR 2D, SEE RELOP) ARG.
	
	MOVE	PNT2,PNT	;PROTECT THIS ONE FROM THE BOLSTO !!!
	PUSHJ	P,BOLSTO	;SPECIAL BOOLEAN STORES.....
	MOVEI	C,6		;THE RIGHT CODES , AND.....
	JRST	VAL0		;GO OUTPUT A SKIPxx OR JUMPxx


↑BOREL1: TLZ	FF,FFTEMP	;TELL NOT TO REMOP THE EXPRESSION.
	PUSHJ	P,BORELL	;THIS IS FOR RELATIONS SUCH AS 1<C<D<34
	MOVE	A,GENRIG+1	;SEMANTICS GENERATED FOR BOOLEAN
	MOVEM	A,GENRIG+3
	MOVE	A,GENLEF+1	;SEMANTICS OF REMAINING EXPRESSION.
	MOVEM	A,GENRIG+1
	MOVE	A,PARLEF	;RELATION TYPE.
	MOVEM	A,PARRIG
	POPJ	P,
SUBTTL	            Relational Operators

;COME HERE TO GENERATE THE COMPARE INSTRUCTION FOR A RELATIONAL OPERATOR.
;THE PARSER PASSES IN REGISTER "B" AN INDEX APPROPRIATE TO THE
;OPERATOR IT SAW.

↑BOREL:	TLO	FF,FFTEMP	;TELL TO REMOP EXPRESSION 1.
BORELL:	
LEP <
	SKIPE	THISE		;IF ARITHMETIC EXPRESSION
	 JRST	 STREL		;THEN DON'T GO TO LEAP
↑↑IREL:				;COME BACK HERE IT ITEM RELATIONS
>;LEP
	GETBLK	<GENRIG+1>	;GET A FREE STORAGE BLOCK FOR BOOLEAN PURPOSES.
	PUSH	P,RELTAB(B)	;CONDITION BITS FOR THIS OPERATOR.
;;#GO# DCS 2-6-72 (4-4)
	PUSHJ	P,GTARGS	;SEMS OF BOTH ARGS TO PNT, ETC., 2D TO AC IF NECC
;;#GO# (4)
LEP <
	TRNN	TBITS,ITEM!ITMVAR
	TRNE	TBITS2,ITEM!ITMVAR
	JRST	RSEMOK
>;LEP
	HRRI	FF,ARITH!BITS2!EXCHOUT!POSIT
				;;GOING TO INSIST ON ARITHMETIC ARGS.
	MOVEI	B,FLOTNG	;IF THEY DON'T AGREE.
	TRNN	TBITS2,FLOTNG
	TRNE	TBITS,FLOTNG	;IF EITHER FLOTING, MAKE BOTH
	TRC	FF,INSIST!ARITH	;FLOTING.
	GENMOV (CONV)		;FIRST ARGUMENT.
	TRZ	FF,EXCHIN!EXCHOUT	;DO IT FOR SECOND ARG.
	GENMOV	(CONV)		;AND SECOND ARGUMENT.
RSEMOK:	TLNE	TBITS2,CNST	;CHECK FOR BOTH CONSTANT
	 JRST	 [TLNN	TBITS,CNST ;WELL?
		  JRST	NTBCN
		  MOVE  A,[CAM B,C] ;PREPARE TO INTERPRET
		  POP	P,C	;CONDITION BITS
		  DPB	C,[POINT 3,A,8]
		  MOVE	B,$VAL(PNT2);ARGS ARE REVERSED AT THIS POINT
		  MOVE	C,$VAL(PNT)
		  PUSHJ	P,REMOP2 ;DITCH SECOND CONST
		  MOVSI	TEMP,TRUCON;ASSUME TRUE
		  XCT	A	;COMPARE
		  JRST	FL	;NOT TRUE
		  JRST	TR]	;TRUE
NTBCN:	TLNN	FF,FFTEMP
	JRST	[GENMOV (GET)
		 JRST TYPOK]

TYPOK:	POP	P,C		;*** SHOULD PROTECT BETTER -- PROBLY IN TOTAL
				;CONDITION BITS.
	PUSHJ	P,BOLSTO	;SPECIAL BOOLEAN STORE.
	TLNE	FF,FFTEMP	;ALWAYS MAKE SURE SECOND ARG. IS LOADED.
	TLNE	TBITS2,CNST	;IF THIS IS CONSTANT, THEN
	JRST	BREV		;WE SHOULD CHANGE ORDER.
	TLNE	SBITS,INAC	;IF THIS IS ¬ IN AC, THEN GOOD ORDER.
	TLNE	TBITS,CNST	;IF THIS IS CONSTANT, NO NEED TO
	JRST	BGOOD		;TEST INAC BITS.
	TLNE	SBITS2,INAC
	JRST	BGOOD

BREV:	HRR	C,CONVT(C)	;REVERSE ORDER OF COMPARE
	JRST	BGET
BGOOD:	TLC	C,1		;INDICATE THAT ONE EXCHOP IS DONE.
	EXCHOP
BGET:	TLNE	TBITS2,CNST	;IS THE SECOND ARG. A CONSTANT?
	SKIPE	$VAL(PNT2)	;IS THE VALUE ZERO ALSO.
	JRST	BGOT		;NO HOPE FOR SEXY THINGS.

VAL0:	TLNN	SBITS,INDXED!PTRAC!FIXARR	;HERE TO GENERATE A SKIPE,
				; SKIPN, JUMPN OR JUMPE.
	TLNN	SBITS,INAC	;IN AN ACCUMULATOR?
	JRST	BSKP		;A SKIP REQUIRED -- NOT IN AC.

BJMP:	HRR	D,$ACNO(PNT)	;GET AC NUMBER.
	TLNN	SBITS,NEGAT	;DO NOT INVERT SENSE
	HRR	C,CONVS(C)	;INVERT THE TEST CONDITIONS.
	MOVE	A,[JUMP USCOND+NOADDR]
	PUSHJ	P,EMITER	;EMIT THE JUMPxx.
	MOVE	A,[XWD 1,$VAL]
	JRST	BODON3		;FINISH OUT AND MARK THE STORAGE BLOCK.
BSKP:	GENMOV	(ACCESS,0)	;GUARANTEE ACCESS TO OUR FRIENDLY ARGUMENT.
				;DO NOT WORRY ABOUT NEGAT -- THIS THING
				;IS IN CORE -- GUARANTEED POSITIVE.
	MOVE	A,[SKIP NOUSAC]
	JRST	BFIN		;FINISH OUT AS WITH CAM.
BGOT:	GENMOV	(GET,POSIT!BITS2!EXCHOUT);MAKE SURE ACCUMULAOR IS FULL.
	TLC	C,1		;INDICATE ANOTHER EXCHOP DONE.
	GENMOV	(ACCESS,0)	;MAKE SURE WE ARE SAFE.
	HRLZI	A,(<CAM>)	;THE COMPARE OPERATION!
BFIN:	TRO	A,USCOND	;INDICATE "C" CONTAINS CONDITION BITS.

GAG <;MAKE SURE THESE GO OUT TOGETHER
	MOVEI	LPSA,2		;WANT TWO
	PUSHJ	P,TWOOUT
>;GAG

	PUSHJ	P,EMITER
	MOVE	A,[XWD 2,$VAL]	;MARK THE STORAGE BLOCK WITH THIS CODE.
	PUSHJ	P,BODON

	MOVE	A,[JRST	NOADDR+NOUSAC]	;THE FOLLOWING JRST.
	PUSHJ	P,EMITER
	MOVE	A,[XWD 2,$VAL2]

BODON3:	TLNN	C,1		;TEST NUMBER OF EXCHOPS
	EXCH	PNT,PNT2	;WE ARE REMOPPING GENLEF+3
	PUSHJ	P,REMOP		;THESE MUST BE REMOPED, IN CASE THEY WERE EXPRS.
	PUSHJ	P,CLEAR		;THEY MUST ALSO BE TOTALLY FORGOTTEN.


;******* THESE REMOPS REALLY WANT TO BE DONE ON THE OPERANDS,
;******* NOT FROM THE SEMANTIC CELLS.  THIS IS BECAUSE IN THE
;******* SPECIAL CASE, WE DO NOT WANT TO DO THE REMOP, E.G. 1<E<F<45 .

BODON1:	EXCH	PNT,PNT2	;PREPARE TO REMOP THE OTHER ARG.
	PUSHJ	P,REMOP
	PUSHJ	P,CLEAR		;LIKE SO.
	TLNE	FF,FFTEMP	;SHOULD WE MAKE A TEMP ?
	 JRST 	 BODON		;NO ----- GO ON.
	MOVEM	A,TBITS2
	SETZM	SBITS		;PREPARE TO MARK.
	GENMOV	(MARK,0)
	MOVEM	PNT,GENLEF+1	;SEE BOREL1 FOR DETAILS OF THIS.
	MOVE	A,TBITS2
↑BODON:	MOVE	LPSA,GENRIG+1	;POINTER TO RESULT BLOCK SET UP BY BOLBLK.
	MOVE	TEMP,LSTRLC	;RELOCATION BIT OF LAST WORD EMITTED.
	TRNE	A,$VAL2		;IS THIS THE FIRST WORD?
	JRST	BSEC		;NO

	HLRM	A,$ACNO(LPSA)
	MOVE	B,PCNT
	SUBI	B,1		;TO GET THE REAL PCNT.
	HRLM	B,$ACNO(LPSA)	;XWD PCNT,TYPE OF COMPARE.
	HRLM	TEMP,$ADR(LPSA)	;RELOCATION FOR FIRST WORD.
	TRNA
BSEC:	HRRM	TEMP,$ADR(LPSA)	;RELOCATION FOR SECOND WORD.
	ADDI	A,(LPSA)	;COMPUTE PLACE TO PUT
	MOVE	B,LSTWRD	;THE LAST WORD OF CODE GENERATED.
	MOVEM	B,(A)
	POPJ	P,
SUBTTL	            Connectives, Negation

DSCR BONOT, BOAND, BOOR
PRO BONOT BOAND BOOR
DES EXECS to combine simple relationals into more complex
 relationals ("rel AND rel" etc.).  These EXECS do not 
 generate code.  They simply create a tree structure for 
 the GBOL De-Morganizer below
SEE Above-mentioned comments for help
⊗
;COME HERE WHEN YOU SEE A "NOT"

↑BONOT:	
	MOVE	PNT,GENLEF+1		;ARGUMENT
	MOVE	A,$DATA(PNT)		;SPEC BITS
	TLNE	A,BOLCON		;TRUE OR FALSE CONSTANT?
	TLCA	A,BOLCON		;YES, INVERT
	TLC	A,GBNOT			;NO, MARK FOR LATER INVERSION
;;#  # DCS TLC STATT TLO ALLOWS ¬¬
	MOVEM	A,$DATA(PNT)		;UPDATE IN MEMORY
	POPJ	P,			;RETURN.


;COME HERE WHEN YOU SEE AN "OR" OR "AND".

↑BOAND:	MOVE	A,GENLEF+3
	MOVEM	A,GENRIG+1		;THE RESULTS IS A PRIMARY ++ BUT.
					;THE KLUDGE IS SO THAT A<B<C WORKS.
	SKIPA	A,[400000+GBAND]
↑BOOR:	MOVEI	A,400000+GBOR
	MOVE	LPSA,GENLEF+3	;FIRST ARGUMENT (TERM OR EXPRESSION)
	MOVE	USER,GENLEF+1	;NEW ARGUMENT.
	HLRZ	D,$DATA(LPSA)	;TYPE OF EXPRESSION
	HLRZ	C,$DATA(USER)	; "   OF 2D
	TRNE	D,BOLCON	;1ST A CONSTANT?
	 JRST	 CONB1		; YES, GO TEST FOR BOTH
	TRNE	C,BOLCON	;2D A CONSTANT?
	 JRST	 CONB2		; YES, GENERATE SIMPLIFIED CODE
CONBAK:	CAME	D,A		;IS THE EXPR (OR TERM) OF THE SAME BOOLEAN
	JRST	BNOSAM		;TYPE? -- NO

	SKIPA	LPSA,$DATA2(LPSA)	;LEFT SON
BOOT:	RIGHT	,$DATA,BOOS	;GO DOWN LOOKING FOR END OF LIST.
		MOVEM	LPSA,LPSAV
		JRST	BOOT

BOOS:	HRRZ	LPSA,LPSAV	;LAST BROTHER.
	HRRM	USER,$DATA(LPSA) ;LINK IN
	POPJ	P,		;RETURN
				;SEMANTICS WILL ATUOMATICALLY BE CORRECT.

BNOSAM:	TRNN	A,GBAND		;AN "AND"?
	JRST	GETWW		;NO -- HAVE NO HOPES.
;	MOVE	USER,GENLEF+1	;*****  KLUDGE FOR A<B<C<D>E TO WORK *****
	HLRZ	D,$DATA(USER)	;THE TYPE,,RIGHT BROTHER POINTER.
	CAME	D,A
	JRST	GETWW
;	MOVE	USER,GENLEF+1	;THIS IS NOW THE GUY WITH THE EXPR. TYXES.
	MOVE	C,$DATA2(USER)	;LEFT SON
;	MOVE	LPSA,GENLEF+3
	HRRM	C,$DATA(LPSA)	;NOW THE BROTHERS ARE LINKED.
	MOVEM	LPSA,$DATA2(USER) ;NEW LEFT SON POINTER.
	MOVEM	USER,GENRIG+1
	POPJ	P,
GETWW:	GETBLK	<GENRIG+1>	;NEED NEW BLOCK.
	
	MOVSM	A,$DATA(LPSA)	;TYPE BITS.
	MOVE	USER,GENLEF+3	;FIRST ARGUMENT.
	HRRZM	USER,$DATA2(LPSA)	;LEFT SON
	MOVE	LPSA,GENLEF+1		;SECOND ARGUMENT.
	HRRM	LPSA,$DATA(USER)		;RIGHT BROTHER.
	POPJ	P,					;RETURN
SUBTTL		    Constant Connectives


; FIRST ARG CONSTANT, CHECK SECOND
CONB1:	TRNN	C,BOLCON	;WELL?
	 JRST	 EXCH2		; NO, REVERSE ARGS, GENERATE SIMPLE CODE
	MOVEM	LPSA,GENRIG+1	;FIRST ARG IS RESULT
	FREBLK	(USER)		;ALL DONE WITH SECOND
	ADD	D,C		;2⊃BOTH FALSE, 3⊃ONE EACH, 4⊃BOTH TRUE
	MOVSI	TEMP,TRUCON	;ASSUME TRUE
	XCT	[JFCL		;BOTH FALSE, FALSE
		 TRNN A,GBOR	;ONE TRUE,   TRUE IF `OR', ELSE FALSE
		 CAIA]-2(D)	;BOTH TRUE,  TRUE
	MOVSI	TEMP,FLSCON	;IF YOU GET HERE, IT WAS FALSE
	MOVEM	TEMP,$DATA(LPSA);UPDATE IN BLOCK
	POPJ	P,

EXCH2:	EXCH	LPSA,USER
	EXCH	D,C		;2D ARG IS THE CONSTANT

;#IM# 2↓ 7-9-72 RHT SWAP 1 & 2 ARGS IN TREE, TOO
	MOVEM	LPSA,GENLEF+3	;PUT THEM BACK FOR GETWW
	MOVEM	USER,GENLEF+1

CONB2:	TRNN	C,TRUCON	;IS 2D ARG TRUE?
	 JRST	 FT		;NO
	TRNN	A,GBOR		;BE `OR' TRUE≡TRUE?
	 JRST	 RETEXP		;NO, BE `AND' TRUE≡BE
	MOVE	B,[JUMP NOUSAC!NOADDR];YES, NO-OP TO TRUE PART
	JRST	ONEOUT
FT:	TRNN	A,GBAND		;BE `AND' FALSE≡FALSE?
	 JRST	 RETEXP		;NO, BE `OR' FALSE≡BE
	MOVE	B,[JUMPA NOUSAC!NOADDR];YES, JUMP-ALWAYS TO FALSE PART
ONEOUT:	HLLZM	B,$VAL(USER)	;THE INSTRUCTION ISSUED
	HRL	TEMP,PCNT
	HRRI	TEMP,1		;PCNT OR JUMP,,JUMP ONLY
	MOVEM	TEMP,$ACNO(USER)
	SETZM	$ADR(USER)	;NO RELOCATION
	SETZM	$DATA(USER)	;NO BROTHERS, NO TYPE BITS
	EXCH	A,B		;GET INSTRUCTION
	PUSHJ	P,EMITER
	MOVE	A,B		;GET TYPE OF CONNECTIVE BACK
	JRST	GETWW		;GO RECORD RESULT

RETEXP:	FREBLK	(USER)		;USELESS BOOLEAN CONSTANT
	MOVEM	LPSA,GENRIG+1	;FIRST ARG IS RESULT
	POPJ	P,
SUBTTL	    Gbol -- Discussion

DSCR GBOL
CAL PUSHJ from IF-type EXECS below
DES Examines the tree set up by above EXECS, re-issues 
  conditional code to reflect proper checks.  Extremely
  convoluted.  See comments above and just below for help
⊗
Comment	⊗

When the boolean expression evaluator GBOL is called, all the code
for testing the boolean conditions has already gone out.  We have
remembered in various free storage blocks the actual code emitted,
and can thus go back and link up the jumps and if necessary change
the sense of the compares or jumps in the test instructions.

The logical nature of the structure has been developed by the calls
on BONOT, BOAND, BOOR above.  These routines have built a tree
structure representing the boolean expression.  The non-terminal
nodes represent connectives.  The handling of NOT is done at all
levels -- a terminal or non-terminal may be marked with GBNOT to
indicate that a NOT preceded this term in the expression.

The basic idea of the GBOL routine is as follows:  When we see the 
connective "AND", we want to arrange for all of the "sons" of
the connective to have tests which fall through when the test
evaluates to TRUE, and jumps out when it evaluates to FALSE.
This desire is indicated by turning on MOSTTRUE and LASTTRUE.
When the major connective is an "OR", we want all but the last
term to fall through on FALSE, and jump on true.  The last term
should fall through on TRUE and jump on FALSE.  These conditions
are indicated by turning off MOSTTRUE and on LASTTRUE.

But this is a simple description.  Suppose the non-terminal
is part of a node which has been directed to fall through on
FALSE.  Then METRUE is off in the state word.  This information
is passed on to the rightmost son.  The other sons do whatever 
the connective specifies.

The NOTS are handled as we descend the tree, changing ¬∧ to ∨, etc.

The bits FLSFIX and TRUFIX are merely used to remember at what
levels we had to start new fixup chains.  When coming back up,
we have to resolve these fixups.




GBOL is called with the pointer to the tree structure in LPSA.
The push-down pointers for FALSE and TRUE are assumed set up
(see STIF, below).  The FALSE stack should already have a 0
pushed onto it.  STATE should contain LASTTRUE -- meaning that
the whole expression wants to fall through on TRUE.
⊗
SUBTTL	    Gbol

	TRUE	←←SP		;TRUE FIXUP PDP
	FALSE	←←PNT2		;FALSE FIXUP PDP
	NXTFIX	←←TBITS2	;THIS IS THE NEXT FIXUP CONTEMPLATED.
	STATE	←←SBITS2	;THE STATE OF THINGS:
				;INVERT,,AND!OR.

GBOL:	MOVE	A,$DATA(LPSA)	;A TERMINAL?
	TLNN	STATE,MOSTTRUE	;COPY MOSTTRUE → METRUE
	TLZA	STATE,METRUE	;METRUE IS BEING FILLED WITH THE
	TLO	STATE,METRUE	;FALL-THROUGH CONDITIONS FOR THIS
				;NODE, WHETHER A TERMINAL OR NOT
	TRNE	A,-1		;IS THERE A RIGHT BROTHER?
	JRST	.+4		;YES -- WE HAVE ALREADY DONE THE RIGHT THING.
	TLNN	STATE,LASTTRUE	;COPY LASTTRUE → METRUE
	TLZA	STATE,METRUE	;SINCE THERE IS NO RIGHT BROTHER, THIS
	TLO	STATE,METRUE	;NODE IS THE "LAST" OF THE DESCENDANTS.  HENCE
				;USE THE "LAST" TEST CONDITIONS.
	JUMPGE	A,GTERM		;IT IS A TERMINAL NODE.


	PUSH	P,STATE		;SAVE IN PREPARATION FOR RECURSION
	PUSH	P,LPSA		;SAVE OLD POINTERS
	TLNE	A,GBNOT		;IS THE CURRENT NODE A "NOT"
	TLC	STATE,GINVRT	;COMPLEMENT INVERTING TYPES.
	TLZ	STATE,FLSFIX!TRUFIX
	HLRZ	TEMP,A		;TYPE BITS
	ANDI	TEMP,GBAND!GBOR	;CONNECTIVES ONLY
	TLNE	STATE,GINVRT	;ARE WE CURRENTLY INVERTING?
	TRC	TEMP,GBAND!GBOR	;YES -- CHANGE THE SENSE OF THE NODE.
	CAIN	TEMP,(STATE)	;SAME AS HIS FATHER?
	JRST	LSON		;YES -- JUST GO CALL RECURSIVELY
	HRR	STATE,TEMP	;NO -- RECORD THE NEW TYPES.
	TRNN	STATE,GBAND	;IF THE THING IS AN ∨, THEN
	TLZA	STATE,MOSTTRUE	;MOST GUYS ARE FALSE.
	TLO	STATE,MOSTTRUE	;ELSE MOST ARE TRUE.
	TLNN	STATE,METRUE	;COPY METRUE → LASTTRUE
	TLZA	STATE,LASTTRUE	;THAT IS, THE REQUIREMENTS ON THIS
	TLO	STATE,LASTTRUE	;NODE ARE TO BE PASSED DOWN.
	TLNN	STATE,METRUE	;IF FALL THROUGH ON FALSE AND
	TRNN	STATE,GBAND	; AN ∧ OPERATION, THEN
	JRST	LAA
	PUSH	FALSE,[0]	;START A NEW FALSE FIXUP
	TLO	STATE,FLSFIX	;AND INDICATE SO.
	JRST	LSON
LAA:	TLNE	STATE,METRUE	;IF FALL THROUGH ON TRUE AND
	TRNN	STATE,GBOR	; AN ∨ OPERATION, THEN
	JRST	LSON
	PUSH	TRUE,[0]	;START A NEW TRUE FIXUP
	TLO	STATE,TRUFIX	;AND RECORD THE FACT.
LSON:	
	HRRZ	LPSA,$DATA2(LPSA)	;GET LEFT SON.
	PUSHJ	P,GBOL		;RECURSIVE CALL.
	POP	P,LPSA		;RESTORE OLD TREE POINTER
	TLNN	STATE,TRUFIX	;WAS A TRUE FIXUP EMITTED?
	JRST	LBB		;NOPE
	POP	TRUE,B
	JRST	FXTO		;FIXUP TO DOOOOO.
LBB:	TLNN	STATE,FLSFIX	;A FALSE FIXUP?
	JRST	LRBRT		;NO -- NONE
	POP	FALSE,B
FXTO:	HLR	B,NXTFIX	;PUT IN THE PCNT OF WHERE THE JUMP GOES.
	PUSHJ	P,FBOUT		;EMIT ONE HIGH-QUALITY FIXUP.
;;;;;	SETZM	NXTFIX		;WE DO NOT RESTART THE FIXUP LOCATION, SINCE
				;WE MAY HAVE TO TERMINATE SEVERAL FIXUP
				;ENTRIES ON THE STACK HERE.
				;CONSIDER A∨(B∧C∧(D∨E)) -- TWO TRUE FIXUPS
				;ARE STARTED WHICH WANT TO TERMINATE AT THE
				;VERY END.
LRBRT:	POP	P,STATE		;RESTORE STATE
	JRST	LRBRO		;AND GO ITERATE OR EXIT



GTERM:	PUSH	P,STATE		;BECAUSE WE WILL CHANGE IT.
;	MOVE	A,$DATA(LPSA)	;XWD  GBNOT(IF ON),,POINTER TO RIGHT BORTH.
	TLZE	A,GBNOT		;IN CASE NOT AT PRIMARY LEVEL.
	TLC	STATE,GINVRT
	MOVE	C,$ACNO(LPSA)	;PCNT,,TYPE
	MOVE	NXTFIX,C	;SAVE IN NXTFIX
	TRNE	C,2		;IF IT IS A TWO-WORD OPERATION,
	AOBJP	C,.+1		;WE ARE INTERESTED IN THE SECOND WORD.
	TLNE	STATE,METRUE	;IF FALL THROUGH ON TRUE, THEN USE
	EXCH	C,(FALSE)	;FALSE FIXUP.
	TLNN	STATE,METRUE
	EXCH	C,(TRUE)	;PROLIFERATE THE RIGHT FIXUP CHAIN.
	TLNE	STATE,GINVRT
	TLC	STATE,METRUE	;NOW STATE TELLS WHETHER TO INVERT THE
GAG <;
	HLRZ	TEMP,NXTFIX	;GET PCNT OF TEST INSTR IN PREP FOR BELOW
	LDB	D,[POINT 3,(TEMP),8] ;GET SENSE BITS.
>;GAG
	TLNE	STATE,METRUE	;COMPARES
	JRST	NOINVRT
NOGAG <;ALLLLLL THIS GOES AWAY IN "GOGOL"
	LDB	D,[POINT 3,$VAL(LPSA),8]
	MOVE	D,CONVS(D)	;INVERT SENSE!
	DPB	D,[POINT 3,$VAL(LPSA),8]
NOINVRT:
	HLRM	C,$VAL2(LPSA)		;STORE FIXUP
	TRNE	NXTFIX,1		;A ONE-WORD OPERATION?
	HLRM	C,$VAL(LPSA)		;YES
	MOVS	TEMP,$ADR(LPSA)
	DPB	TEMP,[POINT 1,BRELC,3]	;RELOCATION BITS.
	MOVE	TEMP,$VAL(LPSA)		;FIRST WORD OF COMPARE
	MOVEM	TEMP,BWRD1		;FIRST WORD IN OUTPUT BLOCK.
	MOVSI	USER,(<1B3>)		;ANOTHER RELOACTION BIT.
	TRNE	NXTFIX,1		;ONE WORD?
	JRST	WOUT			;YES
	MOVE	TEMP,$VAL2(LPSA)	;SECOND WORD.
	MOVEM	TEMP,BWRD2
	MOVSI	USER,(<1B5>)		;RELOCATION BIT FOR THIS WORD.
WOUT:	IORM	USER,BRELC		;TURN IT ON (TENTATIVELY)
	TRNN	TEMP,-1			;IS THE FIXUP ZERO?
	ANDCAM	USER,BRELC		;YES -- TURN OFF THE BIT.
	HLRZM	NXTFIX,BPCNT		;PROGRAM COUNTER
	ADDI	NXTFIX,1		;TO ACCOUNT FOR PCNT WORD.
	HRRM	NXTFIX,BOLOUT		;COUNT
	MOVEI	B,BOLOUT
	PUSHJ	P,GBOUT			;OUTPUT THE BLOCK.
	HRLZI	C,-1(NXTFIX)		;COUNT OF WORDS.
>;NOGAG
GAG <;DO WHAT REALLY NEEDS DOING
	MOVE	D,CONVS(D)
NOINVRT: DPB	D,[POINT 3,(TEMP),8]	;INVERT SENSE
	TRNN	NXTFIX,1		;ONE WORD TEST?
	ADDI	TEMP,1			;NO
	HLRM	C,(TEMP)		;DO FIXUP
	HRLZ	C,NXTFIX		;SIMILAR TO NOGAG OP
>;GAG
	ADD	NXTFIX,C		;NXTFIX POINTS TO INST AFTR TST/JRST.
	POP	P,STATE			;RESTORE STATE OF THINGS.
LRBRO:	FREBLK				;DO NOT NEED IT NO MORE.
	HRRZ	LPSA,$DATA(LPSA)	;RIGHT BROTHER
	JUMPN	LPSA,GBOL		;ITERATE IF THERE IS ONE.
	POPJ	P,			;EXIT IF NOT.
SUBTTL	If-Generators

DSCR STIF, EXIF, EXIF1, EXIF2
PRO STIF, EXIF, EXIF1, EXIF2
DES EXECS to use above De Morganizer to fixup compares and
  things, keep track of TRUE addr, jump to false.
 EXIF and STIF are called when the construct 
     "IF boolean expression THEN" is recognized.  They merely
  call GBOL and save the resulting fixup in the Semantic stack.
 EXIF1 gets the "true" expression the the accumulator.
  The accumulator number was saved in the semantic stack.
 EXIF2 makes sure the types match, then gets the second expression
  into the AC.  A fixup is also written.

 The syntactic contexts are:
 SIF BE THEN → SIFC		STIF
 EIF BE THEN → EIFC		EXIF
 EIFC E ELSE			EXIF1
 EIFC E ELSE E SG → E SG		EXIF2
⊗


↑EXIF:	

↑STIF:
NOGAG <
	PUSHJ	P,FRBT		;FORCE ALL BINARY OUT.
>;NOGAG
	MOVE	LPSA,GENLEF+1	;CHECK FOR CONSTANT BE
	MOVE	A,$DATA(LPSA)
	TLNN	A,BOLCON	;WELL?
	 JRST	 STIFF		;NO
	FREBLK			;DON'T NEED THE CONSTANT
	MOVNI	B,1		;ASSUME TRUE, NO <JRST FALSE> FIXUP
	TLNN	A,FLSCON	;WELL?
	 JRST	 PTWAY		;RIGHT FOR ONCE, NO CODE
	HRL	B,PCNT		;ISSUE <JRST FALSE> TO DISABLE TRUE
	EMIT	(<JRST NOUSAC!NOADDR>)
	JRST	PTWAY

STIFF:	MOVE	TRUE,[IOWD BPDL,TRPDL]
	MOVE	FALSE,[IOWD BPDL,FAPDL]
	MOVSI	STATE,LASTTRUE	;FALL THROUGH ON TRUE !!!!!!
	PUSH	FALSE,[0]	;NEW FALSE FIXUP TO PLAY WITH.
	MOVE	LPSA,GENLEF+1	;SEMANTICS OF BOOLEAN TREE
	SETPOV	(FALSE,DRYROT -- BOOLEAN EXPRESSION STACKS)
	SETPOV	(TRUE,DRYROT -- BOOLEAN EXPRESSION STACKS)
	PUSHJ	P,GBOL		;EVALUATE THE BOOLEAN CODE
	SETPOV	(FALSE,)	;DISABLE THIS ONE
;     TRUE←←SP
	SETPOV	(TRUE,PARSE STACKS -- USE /R TO INCREASE)

	MOVE	B,(FALSE)	;FALSE FIXUP
PTWAY:	HLLM	B,GENRIG	;SAVE IT.
	POPJ	P,


↑EXIF1:	SOJL	B,.+3
	JUMPN	B,LPEXF1	;..LEAP..
	PUSHJ	P,LEVBOL	;LEAVE BOOLEAN MODE.
				;AND FALL THROUGH.....
	GETSEM	(1)		;SEMANTICS OF EXPRESSION
	TRNE	TBITS,STRING
	JRST	[GENMOV (STACK,MRK)
		 MOVNI	A,2
		 ADDM	A,SDEPTH ;SINCE WE ARE GOING TO JRST.
		 JRST EXIF12]
	GENMOV	(GET,POSIT!REM)
EXIF12:	MOVEM	TBITS,GENRIG+1	;AND SAVE EXPRESSION SEMANTICS.
	HRRM	D,GENRIG+2	;SAVE ACCUMULATOR NUMBER.
	PUSHJ	P,ALLSTO	;SAME REASON AS CITED ABOVE.
;THE RESON FOR THE ALLSTO IS SOMETHING LIKE:
; IF I←J+1>1 THEN <COMPLICATED EXPR WHICH FORCES I TO STORE>
;	ELSE <COMPLICATED EXPR WHICH USES I!!>
;
	HRL	PNT2,PCNT	;PRESENT PROGRAM COUNTER (FOR FALSE EXPTR.)
	HLL	B,GENLEF+2	;FALSE FIXUP
	HLLM	PNT2,GENRIG+2	;FIXUP FOR JRST
	MOVE	A,[JRST NOADDR+NOUSAC]
	PUSHJ	P,EMITER
;;#HG#2↓ 5-14-72 DCS (1-4) TEST ENTIRE LEFT HALF (OR /H DOESN'T WORK)
	HLRE	TEMP,B		;IF LEFT HALF IS -1,
	 AOJE	 TEMP,CPOPJ	; NOBODY JUMPED HERE, SO DON'T FIX IT UP
	HRR	B,PCNT		;PREPARE THE FIXUP FOR "FALSE"
	JRST	FBOUT		;FIXUP AND DONE.

↑EXIF2:	SOJL	B,.+3
	JUMPN	B,LPEXF2	;..LEAP..
	PUSHJ	P,LEVBOL	;LEAVE BOOLEAN MODE, AND
				;FALL THROUGH.
	GETSEM	(1)		;THE SECOND EXPRESSION.
	HRRZ	D,GENLEF+4	;THIS IS THE AC NUMBER WE HAVE RESERVED.
	HRRI	FF,POSIT!SPAC!REM
	HRRZ	B,GENLEF+3	;TYPE BITS FROM FIRST GUY.
	CAIE	B,(TBITS)	;THE SAME TYPES?
	TRO	FF,INSIST	;NO
	TRNE	B,STRING
	JRST	[GENMOV (STACK)
		 JRST .+2]
	GENMOV	(GET)		;GO GET THE ARGUMENT IN THE AC.
;	PUSHJ	P,REMOP		;GOT TO RELEASE IT SO THAT
	PUSHJ	P,ALLSTO	;ALLSTO WON'T FIND IT.
	HRR	B,PCNT
	HLL	B,GENLEF+4	;TRUE FIXUP
	PUSHJ	P,FBOUT		;EMIT THE FIXUP.
	JRST	MARK1		;GENMOV(MARK) ↔ MOVEM PNT,GENRIG+1

DSCR IFLS1, IFNLS, IFLS2
PRO IFLS1 IFNLS IFLS2
 These are the routines for the statement level IF
  generation.
 IFLS1 is called when the "else" following an IF xx THEN is
  seen. It outputs a jrst, and a fixup.
 IFNLS is called if we see IF xx THEN ;  .  It merely outputs
  a fixup.
 IFLS2 is called when the statement after the ELSE is
  finished.  It merely outputs a fixup.

 The syntactic contexts are:
 SIFC S ELSE			IFLS1
 SIFC S @END → S @END		IFNLS
 SIFC S ELSE S @END → S @END	IFLS2
⊗

↑IFLS1:	PUSHJ	P,ALLSTO		;STORE EVERYONE IRREVOCABLY.
	MOVE	A,PCNT
	HRLM	A,GENRIG+2	;NEW FIXUP
	MOVE	A,[JRST NOADDR+NOUSAC]
	PUSHJ	P,EMITER		;EMIT THE JRST AROUND FALSE PART.
	SKIPA

↑IFLS2:	SKIPA	B,GENLEF+4
↑IFNLS:	MOVE	B,GENLEF+2
	PUSHJ	P,ALLSTO		;STORE EVERYONE.
;;#HG#2↓ 5-14-72 DCS (2-4) TEST ENTIRE LEFT HALF
	HLRE	TEMP,B		;IF LEFT HALF IS -1, THEN
	 AOJE	 TEMP,CPOPJ	; NOBODY JUMPED HERE, SO DON'T FIX UP
	HRR	B,PCNT
	JRST	FBOUT		;EMIT THE FIXUPS.
SUBTTL		    BE→P Coercion

;THIS IS THE LAST RESORT. A BOOLEAN EXPRESSION WANTS TO BE
;STORED, OR PASSED TO A PROCEDURE, OR SOMETHING.
;SO WE HAPPILY MAKE UP A NUMBER.

↑LEVBOL:ERR	<DRYROT -- SOMETHING EXPOP DIDN'T CATCH>,1
	PUSHJ	P,EXPOP
	MOVE	PNT,GENRIG+1
	MOVEM	PNT,GENLEF+1
	POPJ	P,

↑↑EXPOP1:
	MOVE	TEMP,GENLEF+2	;NEED ONE VALUE, FROM GENLEF+1
	MOVEM	TEMP,GENLEF+1	;FOR ALL OTHERS OF THIS ILK.

↑↑EXPOP:MOVE	LPSA,GENLEF+1	;LOOK FOR CONSTANT BE
	MOVE	A,$DATA(LPSA)
	TLNN	A,BOLCON	;TRUE OR FALSE?
	 JRST	 EXPOP2		;YES, BUT DON'T KNOW WHICH
	FREBLK			;DON'T NEED CONSTANT
	TLNN	A,TRUCON	;TRUE?
	TDZA	A,A		;NO, FALSE
	MOVNI	A,1		;YES, TRUE
	MOVEM	A,SCNVAL
	PUSHJ	P,CREINT	;IT'S JUST A NUMBER
	MOVEM	PNT,GENRIG+1
	POPJ	P,

EXPOP2:	PUSHJ	P,BONOT		;INVERT ALL THE TESTS
	PUSHJ	P,STIF		;GO EVALUATE -- LH OF GENRIG HAS FIXUP.
	PUSHJ	P,GETAN0
	HRL	C,D		;USE AS AC AND ADDR
; FALSE (BECAUSE IF INVERSION ABOVE) VALUE
	EMIT	(<TDZA NORLC!USADDR>)
;	MOVE	B,GENRIG	;FIXUP FOR TRUE (BECAUSE OF INVERSION)
	HRR	B,PCNT
	PUSHJ	P,FBOUT		;EMIT FIXUP.
	HRLI	C,1
	EMIT	<MOVNI USADDR!NORLC>
	PUSHJ	P,MARKINT	;MARK AN INTEGER.
	MOVEM	PNT,GENRIG+1	;AND RECORD RESULT
	POPJ	P,

↑↑CHKCON:GETSEM	(1)		;SEMANTICS OF EXPRESSION
	TLNN	TBITS,CNST	;MUST BE A CONSTANT
	ERR	<SAIL REQUIRES A CONSTANT EXPRESSION HERE>,1
	POPJ	P,

↑↑TWID21:MOVE	TEMP,GENLEF+2	;THIS SHOULD BE IN GEN
	MOVEM	TEMP,GENRIG+1
	POPJ	P,

BEND	BOOLEAN
SUBTTL	For Loop and While Generators.